home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / rts / floatnum.scm < prev    next >
Text File  |  1995-10-13  |  9KB  |  297 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Inexact rational arithmetic using hacked-in floating point numbers.
  4.  
  5. (define-extended-number-type :floatnum (:rational)
  6.   (make-floatnum datum)
  7.   floatnum?
  8.   (datum floatnum-datum))
  9.  
  10. (define (make-float-datum) (make-code-vector 8 0))
  11.  
  12. (define-enumeration flop
  13.   (+ - * / = <
  14.    fixnum->float
  15.    string->float
  16.    float->string
  17.    exp log sin cos tan asin acos atan sqrt
  18.    floor
  19.    integer?
  20.    float->fixnum
  21.    quotient
  22.    remainder))
  23.  
  24. ; Floating point at interrupt level?  Naw!
  25. ; Actually, if floatnum-datum is open-coded, there won't be any
  26. ; opportunity to get an interrupt in any of the situations where
  27. ; floperate is used.
  28.  
  29. (define float-vec (make-vector 3 #f))
  30.  
  31. (define-syntax floperate
  32.   (syntax-rules ()
  33.     ((floperate ?which ?x)
  34.      (vm-extension (+ ?which 100) ?x))
  35.     ((floperate ?which ?x ?y)
  36.      (vm-extension (+ ?which 100) (cons ?x ?y)))
  37.     ((floperate ?which ?x ?y ?z)
  38.      (begin (vector-set! float-vec 0 ?x)
  39.         (vector-set! float-vec 1 ?y)
  40.         (vector-set! float-vec 2 ?z)
  41.         (vm-extension (+ ?which 100) float-vec)))))
  42.  
  43. (define (float&float->float op)
  44.   (lambda (a b)
  45.     (let ((float1 (x->float a))
  46.       (float2 (x->float b))
  47.       (res (make-float-datum)))
  48.       (floperate op
  49.          (floatnum-datum float1)
  50.          (floatnum-datum float2)
  51.          res)
  52.       (make-floatnum res))))
  53.  
  54. (define (float&float->boolean op)
  55.   (lambda (a b)
  56.     (let ((float1 (x->float a))
  57.       (float2 (x->float b)))
  58.       (floperate op
  59.          (floatnum-datum float1)
  60.          (floatnum-datum float2)))))
  61.  
  62. (define (float1 op)
  63.   (lambda (float)
  64.     (floperate op (floatnum-datum float))))
  65.  
  66. (define (float->float op)
  67.   (lambda (a)
  68.     (let ((float (x->float a))
  69.       (res (make-float-datum)))
  70.       (floperate op (floatnum-datum float) res)
  71.       (make-floatnum res))))
  72.  
  73. (define (string->float string)
  74.   (let ((res (make-float-datum)))
  75.     (floperate (enum flop string->float) string res)
  76.     (make-floatnum res)))
  77.  
  78. (define (float->string float)
  79.   (let* ((res (make-string 40 #\space))
  80.      (len (floperate (enum flop float->string)
  81.              (floatnum-datum float)
  82.              res))
  83.      (str (substring res 0 len)))
  84.     (let loop ((i 0))
  85.       (cond ((>= i (string-length str))
  86.          (string-append str "."))
  87.         ((or (char=? (string-ref str i) #\e)
  88.          (char=? (string-ref str i) #\.))
  89.          str)
  90.         (else
  91.          (loop (+ i 1)))))))
  92.  
  93. (define (x->float x)
  94.   (cond ((floatnum? x) x)
  95.     ((integer? x)
  96.      (exact-integer->float (if (exact? x)
  97.                    x
  98.                    (inexact->exact x))))
  99.     ((rational? x)
  100.      ;; This loses when num or den overflows flonum range
  101.      ;; but x doesn't.
  102.      (float/ (numerator x) (denominator x)))
  103.     (else
  104.      (error "cannot coerce to a float" x))))
  105.  
  106. ; Conversion to/from exact integer
  107.  
  108. (define (exact-integer->float k)
  109.   (or (fixnum->float k)
  110.       (float+ (float* (fixnum->float definitely-a-fixnum)
  111.               (quotient k definitely-a-fixnum))
  112.           (fixnum->float (remainder k definitely-a-fixnum)))))
  113.  
  114. (define (fixnum->float k)    ;Returns #f is k is a bignum
  115.   (let ((res (make-float-datum)))
  116.     (if (floperate (enum flop fixnum->float) k res)
  117.     (make-floatnum res)
  118.     #f)))
  119.  
  120. (define (float->exact-integer x)
  121.   (or (float->fixnum x)
  122.       (let ((d (fixnum->float definitely-a-fixnum)))
  123.     (+ (* definitely-a-fixnum
  124.           (float->exact-integer (float-quotient x d)))
  125.        (float->fixnum (float-remainder x d))))))
  126.  
  127. (define definitely-a-fixnum (expt 2 23))    ;Be conservative
  128.  
  129. (define integral-floatnum? (float1 (enum flop integer?)))
  130. (define float->fixnum      (float1 (enum flop float->fixnum)))
  131.  
  132. (define float+ (float&float->float (enum flop +)))
  133. (define float- (float&float->float (enum flop -)))
  134. (define float* (float&float->float (enum flop *)))
  135. (define float/ (float&float->float (enum flop /)))
  136. (define float-quotient (float&float->float (enum flop quotient)))
  137. (define float-remainder (float&float->float (enum flop remainder)))
  138. (define float-atan (float&float->float (enum flop atan)))
  139.  
  140. (define float= (float&float->boolean (enum flop =)))
  141. (define float< (float&float->boolean (enum flop <)))
  142.  
  143. (define float-exp (float->float (enum flop exp)))
  144. (define float-log (float->float (enum flop log)))
  145. (define float-sin (float->float (enum flop sin)))
  146. (define float-cos (float->float (enum flop cos)))
  147. (define float-tan (float->float (enum flop tan)))
  148. (define float-asin (float->float (enum flop asin)))
  149. (define float-acos (float->float (enum flop acos)))
  150. (define float-sqrt (float->float (enum flop sqrt)))
  151. (define float-floor (float->float (enum flop floor)))
  152.  
  153. ; This lets you do ,open floatnum to get faster invocation
  154. (begin 
  155.   (define exp float-exp)
  156.   (define log float-log)
  157.   (define sin float-sin)
  158.   (define cos float-cos)
  159.   (define tan float-tan)
  160.   (define asin float-asin)
  161.   (define acos float-acos)
  162.   (define atan float-atan)
  163.   (define sqrt float-sqrt))
  164.  
  165. (define (float-fraction-length x)
  166.   (let ((two (exact-integer->float 2)))
  167.     (do ((x x (float* x two))
  168.      (i 0 (+ i 1)))
  169.     ((integral-floatnum? x) i)
  170.       (if (> i 1000) (error "I'm bored." x)))))
  171.  
  172. (define (float-denominator x)
  173.   (expt (exact-integer->float 2) (float-fraction-length x)))
  174.  
  175. (define (float-numerator x)
  176.   (float* x (float-denominator x)))
  177.  
  178. (define (float->exact x)
  179.   (if (integral-floatnum? x)
  180.       (float->exact-integer x)        ;+++
  181.       (let ((lose (lambda ()
  182.             (call-error "no exact representation"
  183.                 inexact->exact x)))
  184.         (q (expt 2 (float-fraction-length x))))
  185.     (if (exact? q)
  186.         (let ((e (/ (float->exact-integer
  187.                  (float* x (exact-integer->float q)))
  188.             q)))
  189.           (if (exact? e)
  190.           e
  191.           (lose)))
  192.         (lose)))))
  193.  
  194.  
  195. ; Methods on floatnums
  196.  
  197. (define-method &integer? ((x :floatnum))
  198.   (integral-floatnum? x))
  199.  
  200. (define-method &rational? ((n :floatnum)) #t)
  201.  
  202. (define-method &exact? ((x :floatnum)) #f)
  203.  
  204. (define-method &inexact->exact ((x :floatnum))
  205.   (float->exact x))
  206.  
  207. (define-method &exact->inexact ((x :rational))
  208.   (x->float x))        ;Should do this only if the number is within range.
  209.  
  210. (define-method &floor ((x :floatnum)) (float-floor x))
  211.  
  212. ; beware infinite regress
  213. (define-method &numerator ((x :floatnum)) (float-numerator x))
  214. (define-method &denominator ((x :floatnum)) (float-denominator x))
  215.  
  216. (define (define-floatnum-method mtable proc)
  217.   (define-method mtable ((m :rational) (n :rational)) (proc m n)))
  218.  
  219. (define-floatnum-method &+ float+)
  220. (define-floatnum-method &- float-)
  221. (define-floatnum-method &* float*)
  222. (define-floatnum-method &/ float/)
  223. (define-floatnum-method "ient float-quotient)
  224. (define-floatnum-method &remainder float-remainder)
  225. (define-floatnum-method &= float=)
  226. (define-floatnum-method &< float<)
  227.  
  228. (define-method &numerator ((x :rational)) (float-numerator x))
  229. (define-method &denominator ((x :rational)) (float-denominator x))
  230.  
  231. (define-method &exp ((x :rational)) (float-exp x))
  232. (define-method &log ((x :rational)) (float-log x))
  233. (define-method &sqrt ((x :rational)) (float-sqrt x))
  234. (define-method &sin ((x :rational)) (float-sin x))
  235. (define-method &cos ((x :rational)) (float-cos x))
  236. (define-method &tan ((x :rational)) (float-tan x))
  237. (define-method &acos ((x :rational)) (float-acos x))
  238.  
  239. (define-floatnum-method &atan float-atan)
  240.  
  241. (define-method &number->string ((n :floatnum) radix)
  242.   (if (= radix 10)
  243.       (float->string n)
  244.       (next-method)))
  245.  
  246. ; Oog.
  247.  
  248. (define (float-string? s)
  249.   (let ((len (string-length s)))
  250.     (define (start)
  251.       (cond ((< len 2)
  252.          #f)
  253.         ((char-numeric? (string-ref s 0))
  254.          (digits 1 #f #f))
  255.         ((and (or (char=? (string-ref s 0) #\+)
  256.               (char=? (string-ref s 0) #\-))
  257.           (char-numeric? (string-ref s 1)))
  258.          (digits 2 #f #f))
  259.         ((and (char=? (string-ref s 0) #\.)
  260.           (char-numeric? (string-ref s 1)))
  261.          (digits 2 #t #f))
  262.         (else #f)))
  263.     (define (digits i dot? e?)
  264.       (cond ((>= i len) dot?)
  265.         ((char-numeric? (string-ref s i))
  266.          (digits (+ i 1) dot? e?))
  267.         ((and (char=? (string-ref s i) #\e)
  268.           (not e?))
  269.          (exponent (+ i 1)))
  270.         ((and (char=? (string-ref s i) #\.)
  271.           (not dot?))
  272.          (digits (+ i 1) #t #f))
  273.         (else #f)))
  274.     (define (exponent i)
  275.       (cond ((>= i len) #f)
  276.         ((char-numeric? (string-ref s i))
  277.          (digits (+ i 1) #t #t))
  278.         ((or (char=? (string-ref s i) #\+)
  279.          (char=? (string-ref s i) #\-))
  280.          (exponent2 (+ i 1)))
  281.         (else #f)))
  282.     (define (exponent2 i)
  283.       (cond ((>= i len) #f)
  284.         ((char-numeric? (string-ref s i))
  285.          (digits (+ i 1) #t #t))
  286.         (else #f)))
  287.     
  288.     (start)))
  289.  
  290. (define-simple-type :float-string (:string) float-string?)
  291.  
  292. (define-method &really-string->number ((s :float-string) radix exact?)
  293.   (if (and (= radix 10)
  294.        (not exact?))
  295.       (string->float s)
  296.       (next-method)))
  297.